home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / DDJMAG / DDJ9310.ZIP / 1993-OCT.ZIP / PERL.ASC < prev    next >
Text File  |  1993-09-17  |  5KB  |  160 lines
  1. _NETWORKING WITH PERL_
  2. by Oliver Sharp
  3.  
  4. [LISTING ONE]
  5.  
  6. #! /usr/local/bin/perl
  7. #
  8. #  Usage: PostIt [port-number]
  9. #
  10. #  This sets up a server, which sits around waiting for requests.  There are
  11. # three kinds:
  12. #           "set <tag> <value>" - stash this away
  13. #           "get <tag>" - get a value associated with tag, or return the
  14. #                         list of tags if asked for "alltags"
  15. #           "die" - commit suicide
  16. #
  17. #  If we get a SIGINT signal, close the socket and exit.
  18.  
  19. $parent_pid = $$;              # stash our pid so we can be killed by a child
  20. ($port) = @ARGV;               # see if we have a port argument
  21. $port = 2001 unless $port;     # if not, use 2001
  22.  
  23. $SIG{'INT'} = 'suicide';       # route SIGINT signal to subroutine suicide
  24.  
  25. $family = 2;                   # set up some protocol parameters
  26. $sock_type = 1;
  27. $sockaddr = 'S n a4 x8';
  28. ($name,$aliases,$proto) = getprotobyname('tcp');
  29. $me = pack($sockaddr, $family, $port, "\0\0\0\0");
  30.  
  31. # make the socket, bind it to the protocol, and tell system to start listening
  32. socket(S, $family, $sock_type, $proto) || die "socket: $!\n  ";
  33. bind(S,$me) || die "Tried to bind socket, got: $!\n  ";
  34. listen(S,5) || die "Tried to listen, got: $!\n  ";
  35.  
  36. select(NEW_S);  $| = 1;  select(stdout);    # set auto-flush mode for sockets
  37. select(S);  $| = 1;  select(stdout);
  38.  
  39. for (;;) {
  40.   ($addr = accept(NEW_S,S)) || die $!;      # wait for incoming request
  41.   if (($id = fork()) == 0) {                # fork a child to handle request
  42.     $command = <NEW_S>;
  43.     ($whattodo,$tag,$rest) = split(' ',$command,3);
  44.     chop($rest);
  45.     if ($whattodo eq 'get') {
  46.       if ($tag eq 'alltags') {
  47.       print NEW_S `echo *`;
  48.       }
  49.       else {
  50.     print NEW_S `cat $tag`;
  51.       }
  52.     }
  53.     elsif ($whattodo eq 'set') {
  54.       if (open (TAG,">$tag")) {
  55.         print TAG "$rest\n";
  56.         close(TAG);
  57.         print NEW_S "ok\n";
  58.       }
  59.       else {
  60.         print NEW_S "nope\n";
  61.       }
  62.     }
  63.     elsif ($whattodo eq 'die') {
  64.       print "got a kill\n";
  65.       kill 'SIGINT',$parent_pid;
  66.     }
  67.     else {
  68.       print "got unknown request $whattodo";
  69.     }
  70.     close(NEW_S);
  71.     exit;
  72.   }
  73.   close(NEW_S);
  74. }
  75.  
  76. # when a SIGINT signal comes in, close the socket and exit
  77. sub suicide {
  78.   close S if S;
  79.   print "Suiciding now\n";
  80.   exit;
  81. }
  82.  
  83.  
  84. [LISTING TWO]
  85.  
  86. #! /usr/local/bin/perl
  87. #
  88. #  Usage: getinfo <info-tag> [server-machine server-port]
  89. #         setinfo <info-tag> <value> [server-machine server-port]
  90. #         killserver [server-machine server-port]
  91. #
  92. #  This script tries to contact an info server on the given machine and port.
  93. # If the latter aren't specified, it uses defaults.  If no server is
  94. # found, it complains.  Otherwise, it either gets info about the specified
  95. # tag (if invoked as "getinfo") sets it (if invoked as "setinfo"), or kills
  96. # the server (if invoked as "killserver").  For getinfo, it returns whatever
  97. # info the server returns.  The magic info-tag  "alltags" returns the list 
  98. # of tags that the server has information about.  You aren't allowed to 
  99. # setinfo the word "alltags".
  100.  
  101. if ($0 ne 'killserver') {       # if we are getting or setting info, grab tag
  102.   $tag = shift;
  103. }
  104. if ($0 eq 'setinfo') {          # get value, if we are doing setinfo
  105.   $value = shift;
  106.   die "That's a magic tag ..." if ($value eq 'alltags');
  107. }
  108.  
  109. ($machine,$port) = @ARGV;       # get info about server, if specified
  110. $machine = "master.euphoria.edu" unless $machine;
  111. $port = 2001 unless $port;
  112.  
  113. $family = 2;                   # set up protocol parameters
  114. $sock_type = 1;
  115. $sockaddr = 'S n a4 x8';
  116.  
  117. chop($hostname = `hostname`);
  118. ($name,$aliases,$proto) = getprotobyname('tcp');
  119. ($name,$aliases,$type,$len,$myaddr) = gethostbyname($hostname);
  120. ($name,$aliases,$type,$len,$serveaddr) = gethostbyname($machine);
  121. $me = pack($sockaddr, $family, 0, $myaddr);
  122. $server = pack($sockaddr, $family, $port, $serveaddr);
  123.  
  124. # create socket, bind to protocol, and try to connect to server
  125. socket(S, $family, $sock_type, $proto) || die "Failed to make socket\n  ";
  126. bind(S,$me) || die "Failed to bind socket\n  ";
  127. connect(S,$server) || die "Failed to connect to $machine\n  ";
  128.  
  129. select(S); $| = 1; select(STDOUT);     # set socket to autoflush
  130.  
  131. if ($0 eq 'setinfo') {
  132.   print S "set ",$tag," ",$value,"\n";
  133.   $result = <S>;
  134.   if ($result eq "ok\n") {
  135.     print "Succeeded\n";
  136.   }
  137.   else {
  138.     print "Failed\n";
  139.   }
  140. }
  141. elsif ($0 eq 'getinfo') {
  142.   print S "get ",$tag,"\n";
  143.   $result = <S>;
  144.   if ($result eq "") {
  145.     print "Sorry, no info available about $tag\n";
  146.   }
  147.   else {
  148.     print $result;
  149.   }
  150. }
  151. elsif ($0 eq 'killserver') {
  152.   print S "die";
  153. }
  154. else {
  155.   die "I was invoked with strange name: $0\n  ";
  156. }
  157.  
  158. close(S);
  159.  
  160.